(GLOBAL (FUNCTIONS @
 		   EAR
 		   TOP
 		   CINTERRUPT
 		   VFRAME
 		   CPRINT
 		   CPRIN1
 		   PROGBIND
 		   RUN
 		   START
 		   STOP
 		   PROG
 		   COND
 		   GO
 		   EXIT
 		   RETURN
 		   DISMISS
 		   CEVAL
 		   CERR
 		   CDEFUN
 		   VLOC
 		   RVALUE
 		   CSET
 		   CSETQ
 		   TAG
 		   ACTBLOCK
 		   UNASSIGN
 		   ACCESS
 		   CONTROL
 		   SETACCESS
 		   SETCONTROL
 		   EXPRESSION
 		   CLOSURE
 		   FRAME
 		   CALL
 		   BACKTRACE
 		   LISTEN
 		   CONTINUE
 		   ALLOW
 		   INVOKE
 		   :
 		   /,
 		   !>
 		   !'
 		   !?
 		   !;
 		   !"
 		   !@
 		   !<
 		   !/,)
	(RESERVED ←
 		  *FRAME
 		  CEXPR
 		  "OPTIONAL"
 		  "REST"
 		  "AUX"
 		  *
 		  **
 		  CLAMBDA
 		  *TAG
 		  *AU-REVOIR
 		  ?
 		  <
 		  >
 		  /'
 		  @
 		  "
 		  $
 		  ;
 		  / 
 		  /	
 		  /)))

(DECLARE (SPECIAL OBARRAY READTABLE ERRLIST) (SYMBOLS T) (MACROS T))

(DECLARE (SPECIAL UARGS
 		  BODY
 		  EARGS
 		  CHALOBV
 		  BVARS
 		  ALINK
 		  CLINK
 		  EXP
 		  FRAME*
 		  FREEVARS
 		  FRAMEVARS
 		  LEVNUM
 		  PC
 		  RUNF
 		  TEM
 		  TEM1
 		  TYPE
 		  VAL
 		  VARS
 		  CINTERRUPT
 		  SERRLI
 		  ALLOW
 		  READY
 		  GLOBALS
 		  *
 		  **
 		  ←)
	 (*FEXPR CDEFGEN CDEFUN CERR CONNIVER CSETQ : @ /,)
	 (*LEXPR MATCH ACCESS CONTROL CSET RVALUE VLOC RUN))

(SETQ RUNF
      NIL
      SERRLI
      NIL
      **
      (QUOTE **)
      GLOBALS
      (QUOTE ((NIL NIL) (T T))))

(COMMENT THE
 	 FRAME
 	 FORMAT
 	 IS
 	 AS
 	 FOLLOWS
	 ((IVARS . PC) (BVARS . ALINK) EXP . CLINK))

(SETQ FREEVARS
      (QUOTE (VAL VARS UARGS BODY EARGS TEM TEM1 ALLOW))
      FRAMEVARS
      (QUOTE
       (CHALOBV FRAME* BVARS ALINK CLINK EXP CINTERRUPT READY)))

(DEFPROP BVARS (LAMBDA (L) (LIST (QUOTE CAADR) (CADR L))) MACRO)

(DEFPROP ALINK (LAMBDA (L) (LIST (QUOTE CDADR) (CADR L))) MACRO)

(DEFPROP EXP (LAMBDA (L) (LIST (QUOTE CADDR) (CADR L))) MACRO)

(DEFPROP CLINK (LAMBDA (L) (LIST (QUOTE CDDDR) (CADR L))) MACRO)

(DEFPROP BODY
	 (LAMBDA (L) (QUOTE (CADR (ASSQ (QUOTE *BODY) BVARS))))
 	 MACRO)
(COMMENT THE HACK REALLY BEGINS HERE 0 0 RUN1 IS THE SYSTEM DRIVER)

(DEFPROP RUN
	 (LAMBDA L
	  (PROG NIL
		(SETQ VAL (COND ((= L 1) (ARG 1)) (T NIL)))
		(RETURN (RUN1))))
 	 EXPR)

(DEFPROP RUN1
	 (LAMBDA NIL
	  (PROG NIL
		(COND (RUNF (CERR CONNIVER ALREADY RUNNING)))
		(RETURN
		 ((LAMBDA(BASE IBASE READTABLE)
		   (PROG (RUNF ERET)
			 (SETQ RUNF T)
			 (SETQ ERRLIST SERRLI)
 		    ERRL (SETQ ERET
			       (CATCH
				(PROG NIL
 				 LOOP (COND
				       ((AND CINTERRUPT ALLOW)
					(SETQ PC (HANDLE)))
				       ((SETQ PC (CAP PC))))
				      (GO LOOP))))
			 (COND ((EQ ERET (QUOTE STOP)) (RETURN VAL)))
			 (GO ERRL)))
		  12
		  12
		  (GET (QUOTE CONNIVREAD) (QUOTE ARRAY))))))
 	 EXPR)

(DEFPROP CAP (LAMBDA (P) (APPLY P NIL)) EXPR)

(DEFPROP HANDLE
	 (LAMBDA NIL
	  (PROG2 0
		 (DISPATCH (PROG2 0
				  (CAR CINTERRUPT)
				  (SETQ CINTERRUPT (CDR CINTERRUPT)))
 			   PC
 			   FREEVARS
			   (QUOTE *TOP))
		 (SETQ ALLOW NIL)))
 	 EXPR)

(DEFPROP START
	 (LAMBDA NIL
	  (PROG NIL
		(COND (RUNF (CERR CONNIVER ALREADY RUNNING)))
		(MAPC (QUOTE (LAMBDA (V) (SET V NIL)))
		      (APPEND FRAMEVARS FREEVARS))
		(SETQ PC (QUOTE ICEVAL))
		(SETQ EXP
		      (QUOTE
		       (CEVAL (QUOTE (LISTEN (QUOTE TOP-LEVEL))))))
		(SETQ LEVNUM 0)
		(SETQ ALLOW T)
		(RETURN (RUN1))))
 	 EXPR)

(DEFPROP STOP
	 (LAMBDA N
	  (PROG NIL
		(BREAK CONNIVER-NOT-RUNNING--STOP (NOT RUNF))
		(COND ((= N 0) (SETQ VAL NIL))
		      ((= N 1) (SETQ VAL (ARG 1)))
		      (T (CERR WRONG # OF ARGS)))
		(SETQ PC (QUOTE POPJ))
		(RETURN (THROW (QUOTE STOP)))))
 	 EXPR)

(DEFPROP *STOP
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ PC (QUOTE U-LOSE))
		(RETURN (THROW (QUOTE STOP)))))
 	 EXPR)

(DEFPROP U-LOSE
	 (LAMBDA NIL
	  (PROG NIL
		(CERR ATTEMPT
 		      TO
 		      RUN
 		      A
 		      CONNIVER
 		      PROCESS
 		      WITH
 		      AN
 		      UNDEFINED
 		      PC)
		(RETURN (QUOTE U-LOSE))))
 	 EXPR)

(DEFPROP CERR
	 (LAMBDA(L A)
	  (PROG NIL
		(PRINT (QUOTE **ERROR**))
		(MAPC (QUOTE
		       (LAMBDA(X)
			(PROG NIL
			      (CPRIN1
			       (COND ((ATOM X) X)
				     ((EQ (CAR X) (QUOTE @))
				      (EVAL (CDR X) A))
				     (T X)))
			      (RETURN (PRINC (QUOTE / ))))))
 		      L)
		(CPRINT EXP)
		(RETURN
		 (PROG NIL
		       (PRINT (QUOTE IN-LISP))
 		  LP   (PRINC (QUOTE *))
		       (ERRSET
			(COND
			 ((EQ (SETQ ** (READ)) (QUOTE $P))
			  (RETURN NIL))
			 ((EQ (CAR **) (QUOTE RETURN))
			  (RETURN (EVAL (CADR **) A)))
			 (T (SETQ * (CPRINT (EVAL ** A))))))
		       (SETQ ← **)
		       (GO LP)))))
 	 FEXPR)
(DEFPROP EAR
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ CINTERRUPT
		      (CONS
		       (QUOTE (LISTEN (QUOTE IN-CONNIVER)))
		       CINTERRUPT))
		(SETQ SERRLI ERRLIST)
		(SETQ ERRLIST (QUOTE ((RUN1))))
		(RETURN (IOC G))))
 	 EXPR)

(DEFPROP TOP
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ SERRLI ERRLIST)
		(SETQ ERRLIST (QUOTE ((START))))
		(RETURN (IOC G))))
 	 EXPR)

(DEFPROP CINTERRUPT
	 (LAMBDA(EXP)
	  (NCONC (GET (QUOTE CINTERRUPT) (QUOTE VALUE)) (LIST EXP)))
 	 EXPR)

(DEFPROP ALLOW (LAMBDA (L) (SETQ ALLOW (CAR L))) FEXPR)

(COMMENT DISPATCH IS THE "PUSHJ" FOR CONNIVER)

(DECLARE (SPECIAL ALINK1 EXP1 RETAG SAVE))

(DEFPROP DISPATCH
	 (LAMBDA(EXP1 RETAG SAVE ALINK1)
	  (COND ((NUMBERP EXP1) (SETQ VAL EXP1) RETAG)
		((ATOM EXP1) (SETQ VAL (IVAL EXP1 ALINK1)) RETAG)
		(T
		 (PROG (V F)
		       (SETQ F (CAR EXP1))
 		  BEGIN
		       (COND
			((ATOM F)
			 (COND
			  ((SETQ V
				 (GETL F
				       (QUOTE
					(CINT CEXPR FEXPR FSUBR))))
			   (GO (CAR V)))
			  (T (SAVEUP)
			     (SETQ UARGS (CDR EXP1))
			     (SETQ EARGS NIL)
			     (RETURN (QUOTE EVARGS)))))
			((EQ (CAR F) (QUOTE CLAMBDA))
			 (SAVEUP)
			 (BIND1 (QUOTE *BODY) (CDDR F))
			 (SETQ VARS (CADR F))
			 (SETQ UARGS (CDR EXP1))
			 (RETURN (QUOTE ARGB)))
			((EQ (CAR F) (QUOTE LAMBDA . NIL))
			 (SAVEUP)
			 (SETQ UARGS (CDR EXP1))
			 (SETQ EARGS NIL)
			 (RETURN (QUOTE EVARGS)))
			((EQ (CAR F) (QUOTE *CLOSURE))
			 (SETQ F (CADR F))
			 (GO BEGIN))
			(T (SETQ F
				 (CERR UNKNOWN
 				       FUNCTION
 				       TYPE
				       (@ . EXP1)))
			   (GO BEGIN)))
 		  CINT (SAVEUP)
		       (RETURN (CADR V))
 		  CEXPR
		       (SAVEUP)
		       (BIND1 (QUOTE *BODY) (CDADR V))
		       (SETQ VARS (CAADR V))
		       (SETQ UARGS (CDR EXP1))
		       (RETURN (QUOTE ARGB))
 		  FEXPR
 		  FSUBR
		       (SETQ VAL (EVAL EXP1))
		       (RETURN RETAG)))))
 	 EXPR)

(DEFPROP SAVEUP
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ CLINK
		      (CONS (CONS (SAVEV) RETAG)
			    (COND
			     ((NULL FRAME*)
			      (SETQ CHALOBV NIL)
			      (CONS (CONS BVARS ALINK)
				    (CONS EXP CLINK)))
			     (CHALOBV (SETQ CHALOBV NIL)
				      (CONS
				       (CONS BVARS ALINK)
				       (CDDR FRAME*)))
			     (T (CDR FRAME*)))))
		(SETQ EXP EXP1)
		(SETQ ALINK
		      (COND
		       ((EQ ALINK1 (QUOTE *TOP)) CLINK)
		       (T ALINK1)))
		(SETQ BVARS NIL)
		(RETURN (SETQ FRAME* NIL))))
 	 EXPR)

(DEFPROP SAVEV
	 (LAMBDA NIL
	  (MAPCAR (QUOTE (LAMBDA (V) (CONS V (VALUE V)))) SAVE))
 	 EXPR)

(COMMENT FUNCTION CALLS RETURN VIA "POPJ")
(DEFPROP POPJ
	 (LAMBDA NIL
	  (COND ((SETQ FRAME* CLINK) (RESTORE)) (T (QUOTE *STOP))))
 	 EXPR)

(DEFPROP RESTORE
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ BVARS (CAADR FRAME*))
		(SETQ ALINK (CDADR FRAME*))
		(SETQ EXP (CADDR FRAME*))
		(SETQ CLINK (CDDDR FRAME*))
		(RETURN (REST1))))
 	 EXPR)

(DEFPROP REST1
	 (LAMBDA NIL
	  (PROG NIL
		(MAPC (QUOTE (LAMBDA (X) (SET (CAR X) (CDR X))))
		      (CAAR FRAME*))
		(RETURN (CDAR FRAME*))))
 	 EXPR)

(PUTPROP (QUOTE VALUE)
	 (GET (QUOTE EVAL) (QUOTE LSUBR))
	 (QUOTE LSUBR))

(DECLARE (UNSPECIAL ALINK1 EXP1 RETAG SAVE))

(DEFPROP BIND1
	 (LAMBDA(VAR VAL)
	  (PROG NIL
		(SETQ BVARS (CONS (LIST VAR VAL) BVARS))
		(RETURN (SETQ CHALOBV T))))
 	 EXPR)

(DEFPROP CLOSE
	 (LAMBDA NIL
	  (COND ((ATOM (CAR EXP)))
		((EQ (CAAR EXP) (QUOTE *CLOSURE))
		 (SETQ ALINK (CADDAR EXP))
		 (SETQ CHALOBV T))))
 	 EXPR)

(COMMENT MOBY BINDER 0 0 NORMAL FUNCTION LISTS)

(DEFPROP ARGB
	 (LAMBDA NIL
	  (COND ((NOT (OR VARS UARGS)) (CLOSE) (QUOTE AUXB))
		((AND VARS UARGS)
		 (COND
		  ((ATOM (CAR VARS))
		   (COND
		    ((EQ (CAR VARS) (QUOTE "OPTIONAL"))
		     (SETQ VARS (CDR VARS))
		     (OPTMATCH))
		    ((EQ (CAR VARS) (QUOTE "REST"))
		     (SETQ VARS (CDR VARS))
		     (RESTMATCH))
		    (T
		     (DISPATCH (CAR UARGS)
			       (QUOTE ARGB1)
			       (QUOTE (VARS UARGS))
 			       ALINK))))
		  ((AND (EQ (CAAR VARS) (QUOTE QUOTE))
			(ATOM (CADAR VARS)))
		   (ARGQ))
		  (T (CERR BAD DECLARATION))))
		((AND VARS
		      (OR (EQ (CAR VARS) (QUOTE "OPTIONAL"))
			  (EQ (CAR VARS) (QUOTE "REST"))))
		 (CLOSE)
		 (FINVAR))
		(T (CERR WRONG # OF ARGS))))
 	 EXPR)

(DEFPROP ARGB1
	 (LAMBDA NIL
	  (PROG NIL
		(BIND1 (CAR VARS) VAL)
		(SETQ VARS (CDR VARS))
		(SETQ UARGS (CDR UARGS))
		(RETURN (QUOTE ARGB))))
 	 EXPR)
(DEFPROP ARGQ
	 (LAMBDA NIL
	  (PROG NIL
		(BIND1 (CADAR VARS) (CAR UARGS))
		(SETQ VARS (CDR VARS))
		(SETQ UARGS (CDR UARGS))
		(RETURN (QUOTE ARGB))))
 	 EXPR)

(COMMENT BIND UP "OPTIONAL"S AND "REST"S)

(DEFPROP OPTMATCH
	 (LAMBDA NIL
	  (COND ((NULL UARGS) (CLOSE)
			      (COND
			       ((NULL VARS) (QUOTE AUXB))
			       (T (QUOTE FINVAR))))
		((ATOM (CAR VARS))
		 (COND
		  ((EQ (CAR VARS) (QUOTE "OPTIONAL"))
		   (SETQ VARS (CDR VARS))
		   (QUOTE OPTMATCH))
		  ((EQ (CAR VARS) (QUOTE "REST"))
		   (SETQ VARS (CDR VARS))
		   (QUOTE RESTMATCH))
		  (T
		   (DISPATCH (CAR UARGS)
			     (QUOTE OPTMATCH1)
			     (QUOTE (VARS UARGS))
 			     ALINK))))
		((EQ (CAAR VARS) (QUOTE QUOTE))
		 (COND
		  ((ATOM (CADAR VARS))
		   (BIND1 (CADAR VARS) (CAR UARGS))
		   (SETQ VARS (CDR VARS))
		   (SETQ UARGS (CDR UARGS))
		   (QUOTE OPTMATCH))
		  (T (CERR BAD DECLARATION))))
		((ATOM (CAAR VARS))
		 (DISPATCH (CAR UARGS)
			   (QUOTE OPTMATCH1)
			   (QUOTE (VARS UARGS))
 			   ALINK))
		((AND (EQ (CAAAR VARS) (QUOTE QUOTE))
		      (ATOM (CADAAR VARS)))
		 (BIND1 (CADAAR VARS) (CAR UARGS))
		 (SETQ VARS (CDR VARS))
		 (SETQ UARGS (CDR UARGS))
		 (QUOTE OPTMATCH))
		(T (CERR BAD DECLARATION))))
 	 EXPR)

(DEFPROP OPTMATCH1
	 (LAMBDA NIL
	  (PROG NIL
		(BIND1
		 (COND ((ATOM (CAR VARS)) (CAR VARS))
		       (T (CAAR VARS)))
		 VAL)
		(SETQ VARS (CDR VARS))
		(SETQ UARGS (CDR UARGS))
		(RETURN (QUOTE OPTMATCH))))
 	 EXPR)

(DEFPROP RESTMATCH
	 (LAMBDA NIL
	  (COND ((ATOM (CAR VARS)) (SETQ EARGS NIL) (EVREST))
		((AND (EQ (CAAR VARS) (QUOTE QUOTE))
		      (ATOM (CADAR VARS)))
		 (BIND1 (CADAR VARS) UARGS)
		 (CLOSE)
		 (QUOTE AUXB))
		(T (CERR BAD DECLARATION))))
 	 EXPR)

(DEFPROP EVREST
	 (LAMBDA NIL
	  (COND ((NULL UARGS) (BIND1 (CAR VARS) (REVERSE EARGS))
			      (CLOSE)
			      (QUOTE AUXB))
		(T
		 (DISPATCH (CAR UARGS)
			   (QUOTE EVREST1)
			   (QUOTE (VARS UARGS EARGS))
 			   ALINK))))
 	 EXPR)

(DEFPROP EVREST1
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ UARGS (CDR UARGS))
		(SETQ EARGS (CONS VAL EARGS))
		(RETURN (QUOTE EVREST))))
 	 EXPR)

(COMMENT WHEN RUN OUT OF ARGS BUT HAVE SOME "OPTIONAL"S OR "REST"S)

(DEFPROP FINVAR
	 (LAMBDA NIL
	  (COND ((NULL VARS) (QUOTE AUXB))
		((ATOM (CAR VARS))
		 (COND
		  ((EQ (CAR VARS) (QUOTE "OPTIONAL"))
		   (SETQ VARS (CDR VARS))
		   (QUOTE FINVAR))
		  ((EQ (CAR VARS) (QUOTE "REST"))
		   (SETQ VARS (CDR VARS))
		   (COND
		    ((ATOM (CAR VARS))
		     (BIND1 (CAR VARS) NIL)
		     (QUOTE AUXB))
		    ((AND (EQ (CAAR VARS) (QUOTE QUOTE))
			  (ATOM (CADAR VARS)))
		     (BIND1 (CADAR VARS) NIL)
		     (QUOTE AUXB))
		    (T (CERR BAD DECLARATION))))
		  (T (BIND1 (CAR VARS) (QUOTE *UNASSIGNED))
		     (SETQ VARS (CDR VARS))
		     (QUOTE FINVAR))))
		((EQ (CAAR VARS) (QUOTE QUOTE))
		 (COND
		  ((ATOM (CADAR VARS))
		   (BIND1 (CADAR VARS) (QUOTE *UNASSIGNED))
		   (SETQ VARS (CDR VARS))
		   (QUOTE FINVAR))
		  (T (CERR BAD DECLARATION))))
		((ATOM (CAAR VARS))
		 (DISPATCH (CADAR VARS)
			   (QUOTE FINVAR1)
			   (QUOTE (VARS))
			   (QUOTE *TOP)))
		((AND (EQ (CAAAR VARS) (QUOTE QUOTE))
		      (ATOM (CADAAR VARS)))
		 (DISPATCH (CADAR VARS)
			   (QUOTE FINVAR2)
			   (QUOTE (VARS))
			   (QUOTE *TOP)))
		(T (CERR BAD DECLARATION))))
 	 EXPR)

(DEFPROP FINVAR1
	 (LAMBDA NIL
	  (PROG NIL (BIND1 (CAAR VARS) VAL) (RETURN (FINVAR3))))
 	 EXPR)
(DEFPROP FINVAR2
	 (LAMBDA NIL
	  (PROG NIL (BIND1 (CADAAR VARS) VAL) (RETURN (FINVAR3))))
 	 EXPR)

(DEFPROP FINVAR3
	 (LAMBDA NIL
	  (PROG NIL (SETQ VARS (CDR VARS)) (RETURN (QUOTE FINVAR))))
 	 EXPR)

(COMMENT BINDS "AUX" VARIABLES)

(DEFPROP AUXB
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ BODY (BODY))
		(RETURN
		 (COND ((NULL BODY) (POPJ))
		       ((EQ (CAR BODY) (QUOTE "AUX"))
			(SETQ VARS (CADR BODY))
			(QUOTE AUXB1))
		       (T (QUOTE LINE))))))
 	 EXPR)

(DEFPROP AUXB1
	 (LAMBDA NIL
	  (COND ((NULL VARS) (SETQ BODY (CDDR (BODY))) (QUOTE LINE))
		((ATOM (CAR VARS)) (BIND1 (CAR VARS)
					  (QUOTE *UNASSIGNED))
				   (SETQ VARS (CDR VARS))
				   (QUOTE AUXB1))
		((AND (ATOM (CAAR VARS)) (CDAR VARS))
		 (DISPATCH (CADAR VARS)
			   (QUOTE AUXB2)
			   (QUOTE (VARS))
			   (QUOTE *TOP)))
		(T (CERR BAD DECLARATION))))
 	 EXPR)

(DEFPROP AUXB2
	 (LAMBDA NIL
	  (PROG NIL
		(BIND1 (CAAR VARS) VAL)
		(SETQ VARS (CDR VARS))
		(RETURN (QUOTE AUXB1))))
 	 EXPR)

(DEFPROP CPROG
	 (LAMBDA NIL
	  (PROG NIL
		(BIND1 (QUOTE *BODY) (CDR EXP))
		(RETURN (QUOTE AUXB))))
 	 EXPR)

(DEFPROP PROG CPROG CINT)

(DEFPROP PROGBIND
	 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE PROGB1) NIL ALINK))
 	 EXPR)

(DEFPROP PROGB1
	 (LAMBDA NIL
	  (PROG NIL
		(BIND1 (QUOTE *BODY)
		       (CONS (QUOTE "AUX")
			     (CONS (SETQ VARS VAL) (CDDR EXP))))
		(RETURN (QUOTE AUXB1))))
 	 EXPR)
(DEFPROP PROGBIND PROGBIND CINT)

(COMMENT BASIC PROG ITERATION LOOP)

(DEFPROP LINE
	 (LAMBDA NIL
	  (COND ((NULL BODY) (POPJ))
		(T
		 (DISPATCH (CAR BODY)
			   (QUOTE LINE1)
			   (QUOTE (BODY))
			   (QUOTE *TOP)))))
 	 EXPR)

(DEFPROP LINE1
	 (LAMBDA NIL
	  (PROG NIL (SETQ BODY (CDR BODY)) (RETURN (QUOTE LINE))))
 	 EXPR)

(COMMENT EVALUATES ARGUMENTS TO LISP EXPRS SUBRS AND LSUBRS)

(DEFPROP EVARGS
	 (LAMBDA NIL
	  (COND ((NULL UARGS) (SETQ VAL
				    (APPLY (CAR EXP)
					   (REVERSE EARGS)))
			      (POPJ))
		(T
		 (DISPATCH (CAR UARGS)
			   (QUOTE ARGS1)
			   (QUOTE (UARGS EARGS))
 			   ALINK))))
 	 EXPR)

(DEFPROP ARGS1
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ UARGS (CDR UARGS))
		(SETQ EARGS (CONS VAL EARGS))
		(RETURN (QUOTE EVARGS))))
 	 EXPR)

(COMMENT LOGICAL FLOW OF CONTROL FUNCTIONS)

(DEFPROP CCOND
	 (LAMBDA NIL
	  (PROG NIL (SETQ UARGS (CDR EXP)) (RETURN (CONDLP))))
 	 EXPR)

(DEFPROP CONDLP
	 (LAMBDA NIL
	  (COND ((NULL UARGS) (POPJ))
		(T
		 (DISPATCH (CAAR UARGS)
			   (QUOTE COND1)
			   (QUOTE (UARGS))
 			   ALINK))))
 	 EXPR)
(DEFPROP COND1
	 (LAMBDA NIL
	  (COND (VAL (BIND1 (QUOTE *BODY) (CDAR UARGS)) (QUOTE AUXB))
		(T (SETQ UARGS (CDR UARGS)) (QUOTE CONDLP))))
 	 EXPR)

(DEFPROP COND CCOND CINT)

(DEFPROP IAND
	 (LAMBDA NIL
	  (COND ((NULL (SETQ EXP (CDR EXP))) (OR VAL (SETQ VAL T))
					     (POPJ))
		((DISPATCH (CAR EXP)
			   (QUOTE IAND1)
			   (QUOTE (EXP))
			   (QUOTE *TOP)))))
 	 EXPR)

(DEFPROP IAND1
	 (LAMBDA NIL (COND (VAL (QUOTE IAND)) ((QUOTE POPJ))))
 	 EXPR)

(DEFPROP AND IAND CINT)

(DEFPROP IOR
	 (LAMBDA NIL
	  (COND
	   ((NULL (SETQ EXP (CDR EXP))) (SETQ VAL NIL) (POPJ))
	   ((DISPATCH (CAR EXP)
		      (QUOTE IOR1)
		      (QUOTE (EXP))
		      (QUOTE *TOP)))))
 	 EXPR)

(DEFPROP IOR1 (LAMBDA NIL (COND (VAL (POPJ)) (T (QUOTE IOR)))) EXPR)

(DEFPROP OR IOR CINT)

(COMMENT USERS OF FRAMES 0 0 FLOW OF CONTROL CONTROLLERS)

(DEFPROP CGO
	 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE GO1) NIL ALINK))
 	 EXPR)
(DEFPROP GO1
	 (LAMBDA NIL
	  (COND ((ATOM VAL)
		 (PROG (FR TAG B)
		       (SETQ FR ALINK)
		       (SETQ TAG (QUOTE (: FOO)))
		       (RPLACA (CDR TAG) VAL)
 		  LP   (COND ((NULL FR) (SETQ VAL
					      (CERR TAG NOT FOUND))
					(QUOTE GO1))
			     ((SETQ B
				    (ASSQ (QUOTE *BODY) (BVARS FR)))
			      (COND
			       ((SETQ B (MEMBER TAG (CADR B)))
				(SETQ FRAME* FR)
				(RESTORE)
				(SETQ BODY B)
				(RETURN (QUOTE LINE))))))
		       (SETQ FR (CLINK FR))
		       (GO LP)))
		((EQ (CAR VAL) (QUOTE *TAG))
		 (SETQ FRAME* (CADDR VAL))
		 (RESTORE))
		(T (SETQ VAL (CERR BAD TAG)) (QUOTE GO1))))
 	 EXPR)

(DEFPROP GO CGO CINT)

(DEFPROP CEXIT
	 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE EXIT1) NIL ALINK))
 	 EXPR)

(DEFPROP EXIT1
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ TEM VAL)
		(RETURN
		 (COND
		  ((CDDR EXP)
		   (DISPATCH (CADDR EXP)
			     (QUOTE EXIT2)
			     (QUOTE (TEM))
 			     ALINK))
		  (T
		   (PROG (FR)
			 (SETQ FR ALINK)
 		    LP   (COND ((NULL FR) (CERR EXIT FROM WHAT?))
			       ((ASSQ (QUOTE *BODY) (BVARS FR))
				(SETQ CLINK (CLINK FR))
				(RETURN (POPJ))))
			 (SETQ FR (CLINK FR))
			 (GO LP)))))))
 	 EXPR)

(DEFPROP EXIT2
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ CLINK (CLINK (FR VAL)))
		(SETQ VAL TEM)
		(RETURN (POPJ))))
 	 EXPR)

(DEFPROP EXIT CEXIT CINT)

(DEFPROP CRETURN
	 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE RETURN1) NIL ALINK))
 	 EXPR)

(DEFPROP RETURN1
	 (LAMBDA NIL
	  (PROG (FR)
		(SETQ FR ALINK)
 	   LP   (COND ((NULL FR) (CERR RETURN FROM WHAT?))
		      ((AND (ASSQ (QUOTE *BODY) (BVARS FR))
			    (NOT (EQ (CAR (EXP FR)) (QUOTE COND))))
		       (SETQ CLINK (CLINK FR))
		       (RETURN (POPJ))))
		(SETQ FR (CLINK FR))
		(GO LP)))
 	 EXPR)

(DEFPROP RETURN CRETURN CINT)

(DEFPROP CDISMISS
	 (LAMBDA NIL
	  (COND ((CDR EXP) (SETQ TEM NIL)
			   (DISPATCH (CADR EXP)
				     (QUOTE EXIT2)
				     (QUOTE (TEM))
 				     ALINK))
		(T (SETQ VAL NIL) (RETURN1))))
 	 EXPR)
(DEFPROP DISMISS CDISMISS CINT)

(DEFPROP CONTINUE
	 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE CONT1) NIL ALINK))
 	 EXPR)

(DEFPROP CONT1
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ TEM VAL)
		(RETURN
		 (COND
		  ((CDDR EXP)
		   (DISPATCH (CADDR EXP)
			     (QUOTE CONT2)
			     (QUOTE (TEM))
 			     ALINK))
		  (T (SETQ VAL NIL)
		     (SETQ FRAME* (FR TEM))
		     (RESTORE))))))
 	 EXPR)

(DEFPROP CONT2
	 (LAMBDA NIL
	  (PROG NIL (SETQ FRAME* (FR TEM)) (RETURN (RESTORE))))
 	 EXPR)

(DEFPROP CONTINUE CONTINUE CINT)

(COMMENT RELATIVE EVALUATORS)

(DEFPROP ICEVAL
	 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE CEVAL1) NIL ALINK))
 	 EXPR)

(DEFPROP CEVAL1
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ TEM1 VAL)
		(RETURN
		 (COND
		  ((CDDR EXP)
		   (DISPATCH (CADDR EXP)
			     (QUOTE CEVAL2)
			     (QUOTE (TEM1))
 			     ALINK))
		  (T (SETQ VAL (FRAME)) (QUOTE CEVAL2))))))
 	 EXPR)

(DEFPROP CEVAL2
	 (LAMBDA NIL (DISPATCH TEM1 (QUOTE POPJ) NIL (FR VAL)))
 	 EXPR)

(DEFPROP CEVAL ICEVAL CINT)
(DEFPROP ICALL
	 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE CALL1) NIL ALINK))
 	 EXPR)

(DEFPROP CALL1
	 (LAMBDA NIL
	  (DISPATCH (CONS VAL (CDDR EXP)) (QUOTE POPJ) NIL ALINK))
 	 EXPR)

(DEFPROP CALL ICALL CINT)

(DEFPROP INVOKE
	 (LAMBDA NIL (DISPATCH (CADR EXP) (QUOTE TRY1) NIL ALINK))
 	 EXPR)

(DEFPROP TRY1
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ TEM VAL)
		(RETURN
		 (DISPATCH (CADDR EXP)
			   (QUOTE TRY2)
			   (QUOTE (TEM))
 			   ALINK))))
 	 EXPR)

(DEFPROP TRY2
	 (LAMBDA NIL
	  (PROG NIL
		(SETQ EXP (LIST TEM VAL))
		(SETQ FRAME* NIL)
		(RETURN
		 (PROG (AL METHPAT)
		       (COND
			((NULL
			  (SETQ AL
				(MATCH (SETQ METHPAT (PATTERN TEM))
 				       VAL)))
			 (RETURN (POPJ)))
			(T (SETQ BVARS
				 (NCONC
				  (LIST
				   (LIST (QUOTE *CALLPAT) VAL)
				   (LIST (QUOTE *METHPAT) METHPAT)
				   (LIST
				    (QUOTE *CALLALIST)
				    (CADR AL))
				   (LIST (QUOTE *BODY) (TEXT TEM)))
				  (CAR AL)))
			   (CLOSE)
			   (RETURN (QUOTE AUXB))))))))
 	 EXPR)

(DEFPROP INVOKE INVOKE CINT)

(DEFPROP TEXT
	 (LAMBDA(METH)
	  (COND ((ATOM METH) (TEXT (GET METH (QUOTE DATUM))))
		((EQ (CAR METH) (QUOTE *CLOSURE)) (TEXT (CADR METH)))
		(T (CADDDR METH))))
 	 EXPR)

(DEFPROP FR
	 (LAMBDA(E)
	  (COND ((EQ (CAR E) (QUOTE *FRAME)) (CADR E))
		((EQ (CAR E) (QUOTE *TAG)) (CADDR E))
		((EQ (CAR E) (QUOTE *CLOSURE)) (CADDR E))
		((EQ (CAR E) (QUOTE *AU-REVOIR)) (CADR E))
		(T (CERR BAD FRAME SUPPLIED))))
 	 EXPR)

(COMMENT IDENTIFIER MANIPULATORS)
(DEFPROP VFRAME
	 (LAMBDA N
	  (PROG (FR LOC)
		(SETQ FR
		      (COND ((= N 1) ALINK)
			    ((= N 2) (FR (ARG 2)))
			    (T (CERR WRONG # OF ARGS))))
 	   LP   (COND ((NULL FR) (RETURN NIL))
		      ((SETQ LOC (ASSQ (ARG 1) (BVARS FR)))
		       (RETURN
			(LIST (QUOTE *FRAME) (CHAUX FR) LOC))))
		(SETQ FR (ALINK FR))
		(GO LP)))
 	 EXPR)

(DEFPROP VLOC
	 (LAMBDA N
	  (PROG (FR LOC)
		(SETQ FR
		      (COND
		       ((= N 1)
			(COND
			 ((SETQ LOC (ASSQ (ARG 1) BVARS))
			  (RETURN LOC)))
			ALINK)
		       ((= N 2) (FR (ARG 2)))
		       (T (CERR WRONG # OF ARGS))))
 	   LP   (COND ((NULL FR) (RETURN (ASSQ (ARG 1) GLOBALS)))
		      ((SETQ LOC (ASSQ (ARG 1) (BVARS FR)))
		       (RETURN LOC)))
		(SETQ FR (ALINK FR))
		(GO LP)))
 	 EXPR)

(DEFPROP RVALUE
	 (LAMBDA N
	  ((LAMBDA(LOC)
	    (COND
	     (LOC (COND
		   ((CDDR LOC)
		    (APPLY (CADDR LOC) (LIST (QUOTE RVALUE) LOC))))
		  (CADR LOC))
	     (T (CERR UNBOUND VARIABLE @ (ARG 1)))))
	   (COND ((= N 1) (VLOC (ARG 1)))
		 ((= N 2) (VLOC (ARG 1) (ARG 2)))
		 (T (CERR WRONG # OF ARGS)))))
 	 EXPR)

(DECLARE (SPECIAL ID))

(DEFPROP IVAL
	 (LAMBDA(ID FR)
	  (PROG (ANS)
		(COND
		 ((EQ FR (QUOTE *TOP))
		  (COND
		   ((SETQ ANS (ASSQ ID BVARS)) (GO FOUND))
		   (T (SETQ FR ALINK)))))
 	   LP   (COND
		 ((NULL FR)
		  (COND
		   ((SETQ ANS (ASSQ ID GLOBALS)) (GO FOUND))
		   (T (RETURN (CERR UNBOUND VARIABLE (@ . ID))))))
		 ((SETQ ANS (ASSQ ID (BVARS FR))) (GO FOUND)))
		(SETQ FR (ALINK FR))
		(GO LP)
 	   FOUND
		(COND
		 ((CDDR ANS)
		  (APPLY (CADDR ANS) (LIST (QUOTE /,) ANS))))
		(COND
		 ((EQ (SETQ ANS (CADR ANS)) (QUOTE *UNASSIGNED))
		  (RETURN (CERR UNASSIGNED VARIABLE (@ . ID)))))
		(RETURN ANS)))
 	 EXPR)

(DECLARE (UNSPECIAL ID))

(DEFPROP ICSETQ
	 (LAMBDA NIL (PROG NIL (SETQ UARGS EXP) (RETURN (CSETQ0))))
 	 EXPR)

(DEFPROP CSETQ0
	 (LAMBDA NIL
	  (COND
	   ((CDR UARGS)
	    (COND
	     ((AND (ATOM (CADR UARGS)) (CDDR UARGS))
	      (DISPATCH (CADDR UARGS)
			(QUOTE CSETQ1)
			(QUOTE (UARGS))
 			ALINK))
	     (T (CERR BAD CALL) (POPJ))))
	   (T (POPJ))))
 	 EXPR)

(DEFPROP CSETQ1
	 (LAMBDA NIL
	  (PROG NIL
		((LAMBDA(LOC)
		  (COND
		   (LOC
		    (COND
		     ((CDDR LOC)
		      (APPLY (CADDR LOC)
			     (LIST (QUOTE CSET) LOC VAL))))
		    (RPLACA (CDR LOC) VAL))
		   (T
		    (SETQ GLOBALS
			  (CONS (LIST (CADR UARGS) VAL) GLOBALS)))))
		 (VLOC (CADR UARGS)))
		(SETQ UARGS (CDDR UARGS))
		(RETURN (QUOTE CSETQ0))))
 	 EXPR)

(DEFPROP CSETQ (LAMBDA (L) (CSET (CAR L) (EVAL (CADR L)))) FEXPR)
(DEFPROP CSETQ ICSETQ CINT)

(DEFPROP CSET
	 (LAMBDA N
	  ((LAMBDA(LOC)
	    (PROG NIL
		  (COND
		   (LOC
		    (COND
		     ((CDDR LOC)
		      (APPLY (CADDR LOC)
			     (LIST (QUOTE CSET) LOC (ARG 2)))))
		    (RPLACA (CDR LOC) (ARG 2)))
		   (T
		    (SETQ GLOBALS
			  (CONS (LIST (ARG 1) (ARG 2)) GLOBALS))))
		  (RETURN (ARG 2))))
	   (COND ((= N 2) (VLOC (ARG 1)))
		 ((= N 3) (VLOC (ARG 1) (ARG 3)))
		 (T (CERR WRONG # OF ARGS)))))
 	 EXPR)

(DEFPROP UNASSIGN (LAMBDA (VAR) (CSET VAR (QUOTE *UNASSIGNED))) EXPR)

(COMMENT FRAME CONSTRUCTORS)

(DEFPROP CHAUX
	 (LAMBDA(FR)
	  (COND ((NULL FR) NIL)
		((EQ (CDAR FR) (QUOTE AUXB1))
		 (CERR ATTEMPT TO RETURN INCOMPLETE FRAME))
		(T FR)))
 	 EXPR)

(DEFPROP TAG
	 (LAMBDA(NAME)
	  (PROG (FR B TAG)
		(SETQ FR ALINK)
		(SETQ TAG (QUOTE (: FOO)))
		(RPLACA (CDR TAG) NAME)
 	   LP   (COND ((NULL FR) (RETURN NIL))
		      ((SETQ B (ASSQ (QUOTE *BODY) (BVARS FR)))
		       (COND
			((SETQ B (MEMBER TAG (CADR B)))
			 (CHAUX FR)
			 (RETURN
			  (LIST (QUOTE *TAG)
 				NAME
				(CONS
				 (CONS
				  (LIST (CONS (QUOTE BODY) B))
				  (QUOTE LINE))
				 (CDR FR))))))))
		(SETQ FR (CLINK FR))
		(GO LP)))
 	 EXPR)

(DEFPROP ACTBLOCK
	 (LAMBDA NIL
	  (PROG (FR B)
		(SETQ FR ALINK)
 	   LP   (COND ((NULL FR) (RETURN NIL))
		      ((SETQ B (ASSQ (QUOTE *BODY) (BVARS FR)))
		       (CHAUX FR)
		       (COND
			((EQ (CAR B) (QUOTE "AUX"))
			 (SETQ B (CDDR B))))
		       (RETURN
			(LIST (QUOTE *TAG)
			      (QUOTE *ACTBLOCK)
			      (CONS
			       (CONS
				(LIST (CONS (QUOTE BODY) B))
				(QUOTE LINE))
			       (CDR FR))))))
		(SETQ FR (CLINK FR))
		(GO LP)))
 	 EXPR)

(DEFPROP ACCESS
	 (LAMBDA N
	  (LIST (QUOTE *FRAME)
		(CHAUX
		 (COND ((= N 0) (ALINK ALINK))
		       ((= N 1) (ALINK (FR (ARG 1))))
		       (T (CERR WRONG # OF ARGS))))))
 	 EXPR)

(DEFPROP CONTROL
	 (LAMBDA N
	  (LIST (QUOTE *FRAME)
		(CHAUX
		 (COND ((= N 0) (CLINK ALINK))
		       ((= N 1) (CLINK (FR (ARG 1))))
		       (T (CERR WRONG # OF ARGS))))))
 	 EXPR)

(DEFPROP CLOSURE
	 (LAMBDA N
	  (PROG NIL
		(COND ((OR (< N 1) (> N 2)) (CERR WRONG # OF ARGS)))
		(RETURN
		 (LIST (QUOTE *CLOSURE)
		       (ARG 1)
		       (CHAUX
			(COND ((= N 2) (FR (ARG 2))) (T ALINK)))))))
 	 EXPR)
(DEFPROP FRAME (LAMBDA NIL (LIST (QUOTE *FRAME) (CHAUX ALINK))) EXPR)

(COMMENT VERY DANGEROUS USER (HA!) FUNCTIONS)

(DEFPROP SETACCESS
	 (LAMBDA(T1 S)
	  (PROG NIL
		(SETQ T1 (FR T1))
		(SETQ S (FR S))
		(RPLACD (CADR T1) S)
		(RETURN (QUOTE BOOM!))))
 	 EXPR)

(DEFPROP SETCONTROL
	 (LAMBDA(T1 S)
	  (PROG NIL
		(SETQ T1 (FR T1))
		(SETQ S (FR S))
		(RPLACD (CDDR T1) S)
		(RETURN (QUOTE BOOM!))))
 	 EXPR)

(DEFPROP CEVAL
	 (LAMBDA N
	  ((LAMBDA(PC EXP ALINK)
	    (PROG (CLINK FRAME* BVARS CHALOBV RUNF) (RETURN (RUN1))))
	   (QUOTE ICEVAL)
	   (LIST (QUOTE CEVAL) (LIST (QUOTE QUOTE) (ARG 1)))
	   (COND ((> N 1) (FR (ARG 2))) (T ALINK))))
 	 EXPR)

(COMMENT DEBUGGING AIDS)

(DEFPROP EXPRESSION (LAMBDA (F) (EXP (FR F))) EXPR)

(DEFPROP BACKTRACE
	 (LAMBDA N
	  (PROG (FR E B M TEM)
		(SETQ FR (FRAME))
		(COND ((= N 0) (SETQ M 777777)) (T (SETQ M (ARG 1))))
		(COND ((= N 2) (SETQ TEM (ARG 2))))
 	   LP   (COND
		 ((OR (NULL (CADR FR)) (= M 0))
		  (RETURN (QUOTE END-OF-BACKTRACE))))
		(SETQ E (EXPRESSION FR))
		(COND
		 ((SETQ B (GET (CAR E) (QUOTE BACKTRACE)))
		  (APPLY B (LIST FR (CDR E))))
		 (T (CPRINT E)))
		(COND (TEM (CPRIN1 (CAADR FR))))
		(SETQ FR (CONTROL FR))
		(SETQ M (/1- M))
		(GO LP)))
 	 EXPR)

(DEFPROP LISTENB
	 (LAMBDA(FR ARG)
	  (PROG NIL
		(PRINT (IVAL (QUOTE EAR) (CADR FR)))
		(CPRIN1 (IVAL (QUOTE MESSAGE) (CADR FR)))
		(RETURN (PRINC (QUOTE / )))))
 	 EXPR)

(DEFPROP LISTEN LISTENB BACKTRACE)
(DEFPROP CONDB (LAMBDA (FR ARG) (PRINT (QUOTE COND))) EXPR)

(DEFPROP COND CONDB BACKTRACE)

(DEFPROP PROGB (LAMBDA (FR ARG) (PRINT (QUOTE PROG))) EXPR)

(DEFPROP PROG PROGB BACKTRACE)

(DEFPROP CEVALB
	 (LAMBDA (FR ARG) (COND (TEM (PRINT (QUOTE CEVAL)))))
 	 EXPR)

(DEFPROP CEVAL CEVALB BACKTRACE)

(DEFPROP UPDATEB (LAMBDA (FR ARG) NIL) EXPR)

(DEFPROP UPDATE UPDATEB BACKTRACE)

(DEFPROP SETB
	 (LAMBDA(FR ARG)
	  (OR (MEMBER (CAR ARG) (QUOTE ((QUOTE *) (QUOTE **))))
	      (PRINT (CONS (QUOTE SET) ARG))))
 	 EXPR)

(DEFPROP SET SETB BACKTRACE)
(DEFPROP PROGBINDB (LAMBDA (FR ARG) (PRINT (QUOTE PROGBIND))) EXPR)

(DEFPROP PROGBIND PROGBINDB BACKTRACE)

(COMMENT USER INTERFACE)

(DEFPROP CDEFUN
	 (LAMBDA(L)
	  (PROG NIL
		(PUTPROP (CAR L) (CDR L) (QUOTE CEXPR))
		(RETURN (CAR L))))
 	 FEXPR)

(CDEFUN LISTEN
	(MESSAGE)
        "AUX"
	((EAR (GENLEV)))
	(ALLOW T)
	(CPRINT MESSAGE)
	(PROGBIND (LIST EAR (QUOTE LOOP))
		  (CSET EAR (TAG (QUOTE EAR)))
		  (CSETQ LOOP (TAG (QUOTE LOOP)))
		  (: EAR)
		  (PRINT EAR)
		  (: LOOP)
		  (SETQ ← **)
		  (@ PRINT (QUOTE ←))
		  (SET (QUOTE *) (CEVAL (SETQ ** (READ))))
		  (@ CPRINT *)
		  (GO LOOP)))

(DEFPROP GENLEV
	 (LAMBDA NIL
	  (READLIST
	   (APPEND (QUOTE (E A R 0))
		   (EXPLODE (SETQ LEVNUM (ADD1 LEVNUM))))))
 	 EXPR)

(DEFPROP : (LAMBDA (L) L) FEXPR)

(DEFPROP @ (LAMBDA (\L) (EVAL \L)) FEXPR)

(DEFPROP /, (LAMBDA (L) (IVAL (CAR L) (QUOTE *TOP))) FEXPR)

(DEFPROP CPRIN1
	 (LAMBDA(X)
	  (PROG (Y)
		(COND ((ATOM X) (PRIN1 X) (RETURN X))
		      ((AND (ATOM (CAR X))
			    (SETQ Y (GET (CAR X) (QUOTE CPRINT))))
		       (APPLY Y X)
		       (RETURN X)))
		(SETQ Y X)
		(PRINC (QUOTE /())
 	   PLOOP
		(CPRIN1 (CAR Y))
		(COND
		 ((NULL (SETQ Y (CDR Y)))
		  (PRINC (QUOTE /)))
		  (RETURN X))
		 ((ATOM Y) (PRINC (QUOTE / /./ ))
			   (PRIN1 Y)
			   (PRINC (QUOTE /)))
			   (RETURN X)))
		(PRINC (QUOTE / ))
		(GO PLOOP)))
 	 EXPR)
(DEFPROP CPRINT
	 (LAMBDA(X)
	  (PROG NIL
		(PRINC (QUOTE //))
		(CPRIN1 X)
		(PRINC (QUOTE / ))
		(RETURN X)))
 	 EXPR)

(DEFPROP CP-MACR
	 (LAMBDA(E)
	  (PROG NIL (PRINC (CAR E)) (RETURN (PRIN1 (CADR E)))))
 	 FEXPR)

(DEFPROP : CP-MACR CPRINT)

(DEFPROP /, CP-MACR CPRINT)

(DEFPROP CP-QUOTE
	 (LAMBDA(E)
	  (PROG NIL (PRINC (QUOTE /')) (RETURN (CPRIN1 (CADR E)))))
 	 FEXPR)

(DEFPROP QUOTE CP-QUOTE CPRINT)

(DEFPROP CP-*TAG
	 (LAMBDA(TAG)
	  (PROG NIL
		(PRINC (QUOTE /())
		(PRIN1 (CAR TAG))
		(PRINC (QUOTE / ))
		(CPRIN1 (CADR TAG))
		(PRINC (QUOTE / ))
		(CPRIN1 (EXP (CADDR TAG)))
		(RETURN (PRINC (QUOTE /))))))
 	 FEXPR)

(DEFPROP *TAG CP-*TAG CPRINT)

(DEFPROP *CLOSURE CP-*TAG CPRINT)

(DEFPROP CP-*FRAME
	 (LAMBDA(FRAME)
	  (PROG NIL
		(PRINC (QUOTE /())
		(PRIN1 (CAR FRAME))
		(PRINC (QUOTE / ))
		(CPRIN1 (EXP (CADR FRAME)))
		(RETURN (PRINC (QUOTE /))))))
 	 FEXPR)
(DEFPROP *FRAME CP-*FRAME CPRINT)

(DEFPROP *AU-REVOIR CP-*FRAME CPRINT)

(DEFPROP CP-MATCH
	 (LAMBDA(E)
	  (PROG NIL
		(PRINC (CAR E))
		(RETURN
		 (COND ((CDDR E) (CPRIN1 (CDR E)))
		       ((CADR E) (CPRIN1 (CADR E)))))))
 	 FEXPR)

(DEFPROP !> CP-MATCH CPRINT)

(DEFPROP !' CP-MATCH CPRINT)

(DEFPROP !? CP-MATCH CPRINT)

(DEFPROP !; CP-MATCH CPRINT)

(DEFPROP !< CP-MATCH CPRINT)

(DEFPROP !/, CP-MATCH CPRINT)

(DEFPROP !@ CP-MATCH CPRINT)
(DEFPROP CP-!"
	 (LAMBDA(E)
	  (PROG NIL (PRINC (CAR E)) (RETURN (CPRIN1 (CDR E)))))
 	 FEXPR)

(DEFPROP !" CP-!" CPRINT)

(DEFPROP @ CP-!" CPRINT)

(DEFPROP COLMAC (LAMBDA NIL (LIST (QUOTE :) (READ))) EXPR)

(DEFPROP COMMAC (LAMBDA NIL (LIST (QUOTE /,) (READ))) EXPR)

(DEFPROP ATMAC (LAMBDA NIL (CONS (QUOTE @) (READ))) EXPR)

(DEFPROP EXMAC
	 (LAMBDA NIL
	  (PROG (C F)
		(SETQ C (NXTCHR))
		(COND ((EQ C (QUOTE $)) (TYI)
					(RETURN
					 ((LAMBDA (OBARRAY) (READ))
					  (GET
					   (QUOTE CONNIVER)
					   (QUOTE ARRAY)))))
		      ((EQ C (QUOTE ")) (TYI)
					(RETURN
					 (CONS (QUOTE !") (READ))))
		      ((SETQ F
			     (ASSQ C
				   (QUOTE
				    ((? !?) (/' !')
					    (@ !@)
					    (> !>)
					    (/, !/,)
					    (< !<)
					    (; !;)))))
		       (TYI)
		       (SETQ F (CADR F)))
		      (T (PRINT
			  (LIST (QUOTE BAD)
				(QUOTE !)
				(QUOTE MACRO)
 				C))
			 (IOC G)))
		(RETURN
		 (COND ((SEPARATOR (NXTCHR)) (LIST F NIL))
		       ((ATOM (SETQ C (READ))) (LIST F C))
		       (T (CONS F C))))))
 	 EXPR)

(DEFPROP NXTCHR (LAMBDA NIL (ASCII (TYIPEEK))) EXPR)

(DEFPROP SEPARATOR
	 (LAMBDA (CHAR) (MEMQ CHAR (QUOTE (/  /	 /)))))
 	 EXPR)

(MAKREADTABLE (QUOTE CONNIVREAD))
((LAMBDA(READTABLE)
  (PROG NIL
	(SSTATUS MACRO : (QUOTE COLMAC))
	(SSTATUS MACRO /, (QUOTE COMMAC))
	(SSTATUS MACRO @ (QUOTE ATMAC))
	(RETURN (SSTATUS MACRO ! (QUOTE EXMAC)))))
 (GET (QUOTE CONNIVREAD) (QUOTE ARRAY)))